home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1995 August: Tool Chest / Dev.CD Aug 95 TC / Dev.CD Aug 95 TC.toast / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / find-method-dialog / find-method-dialog.lisp next >
Encoding:
Text File  |  1994-09-12  |  6.4 KB  |  161 lines  |  [TEXT/CCL2]
  1. ;
  2. ;    find-method-dialog.lisp
  3. ;
  4. ;    Masaya UEDA
  5. ;    ueda@shpcs.sharp.co.jp
  6.  
  7. (defclass alist-dialog-item (sequence-dialog-item)
  8.   ((alist :initform nil :accessor alist)))
  9.  
  10. (defmethod (setf alist) :after ((l list) (adi alist-dialog-item))
  11.   (set-table-sequence adi (mapcar 'car l)))
  12.  
  13. ; ---
  14.  
  15. (defclass mini-buffer-mixin ()
  16.   ((mini-buffer :initform (make-instance 'mini-buffer)
  17.                 :accessor view-mini-buffer)
  18.    (mini-buffer-dialog-item :initarg :window-mini-buffer-dialog-item
  19.                             :accessor window-mini-buffer-dialog-item))
  20.   (:default-initargs :window-mini-buffer-dialog-item nil)
  21.   (:documentation "This class need to be mixed with class window or it's descendants"))
  22.  
  23. (defclass window-with-mini-buffer (mini-buffer-mixin window) ())
  24.  
  25. (defclass dialog-with-mini-buffer (mini-buffer-mixin dialog) ())
  26.  
  27. (defmethod initialize-instance :after ((window mini-buffer-mixin)
  28.                                        &rest initargs
  29.                                        &key window-mini-buffer-dialog-item)
  30.   (declare (dynamic-extent initargs)
  31.            (ignore initargs))
  32.   (if window-mini-buffer-dialog-item
  33.     (add-subviews window window-mini-buffer-dialog-item)))
  34.  
  35. (defmethod mini-buffer-update ((window mini-buffer-mixin))
  36.   (let ((mb (view-mini-buffer window)))
  37.     (set-dialog-item-text (window-mini-buffer-dialog-item window)
  38.                           (mini-buffer-string mb))
  39.     (setf (slot-value mb 'ccl::string-changed) nil)))
  40.  
  41. (defmethod mini-buffer-update ((fdi fred-dialog-item))
  42.   (let ((vw (view-window fdi)))
  43.     (if (typep vw 'mini-buffer-mixin)
  44.       (mini-buffer-update vw))))
  45.  
  46. (if (find :COMPLETION *modules* :test #'string=)
  47.   (defmethod ccl::display-mini-buffer-completion ((window mini-buffer-mixin))
  48.     (let ((fdi (current-key-handler window)))
  49.       (and *completion* fdi
  50.            (set-dialog-item-text (window-mini-buffer-dialog-item window)
  51.                                  ccl::*last-completion-word-displayed*)))))
  52.  
  53. (defmethod fred-update ((window mini-buffer-mixin))
  54.   (let ((ckh (current-key-handler window)))
  55.     (typep ckh 'fred-mixin)
  56.       (fred-update ckh)))
  57.  
  58. (defmethod set-mini-buffer ((window mini-buffer-mixin) string
  59.                             &rest format-args)
  60.   (declare (dynamic-extent format-args))
  61.   (let ((ckh (current-key-handler window)))
  62.     (if (typep ckh 'fred-mixin)
  63.       (apply #'set-mini-buffer ckh string format-args))))
  64.  
  65. (defmethod window-eval-selection ((window mini-buffer-mixin)
  66.                                   &optional (evalp nil evalp?))
  67.   (let ((ckh (current-key-handler window)))
  68.     (if (typep ckh 'fred-mixin)
  69.       (if evalp?
  70.         (window-eval-selection ckh evalp)
  71.         (window-eval-selection ckh)))))
  72.  
  73. (defmethod deselect-all-cells ((tdi table-dialog-item))
  74.   (dolist (cell (selected-cells tdi))
  75.     (cell-deselect tdi cell)))
  76.  
  77. ; ---
  78.  
  79. (defun make-find-method-dialog ()
  80.   (labels ((find (item)
  81.              (let ((f (fboundp
  82.                        (read-from-string
  83.                         (dialog-item-text
  84.                          (find-named-sibling item 'etdi))
  85.                         nil)))
  86.                    (adi (find-named-sibling item 'adi)))
  87.                (typecase f
  88.                  (generic-function
  89.                    (deselect-all-cells adi)
  90.                    (setf (alist adi)
  91.                          (mapcar #'(lambda (m)
  92.                                      (cons (list (method-qualifiers m)
  93.                                                  (mapcar #'(lambda (ms)
  94.                                                              (if (typep ms 'class)
  95.                                                                (class-name ms)
  96.                                                                ms))
  97.                                                          (method-specializers m)))
  98.                                            m))
  99.                                  (generic-function-methods f))))
  100.                  (otherwise
  101.                   (setf (alist adi) nil))))
  102.              (dialog-item-disable (find-named-sibling item 'remove)))
  103.            (remove (item)
  104.              (let* ((adi (find-named-sibling item 'adi))
  105.                     (alist (alist adi)) method)
  106.                (dolist (cell (selected-cells adi))
  107.                  (setq method (cdr (nth (cell-to-index adi cell) alist)))
  108.                  (remove-method (method-generic-function method) method)))
  109.              (find item))
  110.            (adia (item &aux (sc (selected-cells item)))
  111.              (cond (sc (dialog-item-enable (find-named-sibling item 'remove))
  112.                        (if (double-click-p)
  113.                          (dolist (cell sc)
  114.                            (print (cdr (nth (cell-to-index item cell) (alist item)))))))
  115.                    (t (dialog-item-disable (find-named-sibling item 'remove))))))
  116.     (make-instance 'dialog-with-mini-buffer
  117.       :window-type :document
  118.       :window-title "Find Method Dialog"
  119.       :view-position '(:bottom 10)
  120.       :view-size #@(300 150)
  121.       :view-font '("osaka" 12 :srcor :plain)
  122.       :window-mini-buffer-dialog-item
  123.       (make-dialog-item 'static-text-dialog-item
  124.         #@(4 124) #@(152 24) "" 'nil
  125.         :view-nick-name 'stdi
  126.         :view-font '("monaco" 9 :srcor :plain))
  127.       :view-subviews
  128.       (list (make-dialog-item 'editable-text-dialog-item
  129.               #@(5 5) #@(290 14) "" 'nil
  130.               :view-nick-name 'etdi
  131.               :view-font '("monaco" 9 :srcor :plain)
  132.               :allow-returns nil)
  133.             (make-dialog-item 'button-dialog-item
  134.               #@(234 128) #@(61 16) "remove" #'remove
  135.               :view-nick-name 'remove
  136.               :view-font '("geneva" 12 :srcor :plain)
  137.               :default-button nil
  138.               :dialog-item-enabled-p nil)
  139.             (make-dialog-item 'button-dialog-item
  140.               #@(164 128) #@(61 16) "find" #'find
  141.               :view-nick-name 'find
  142.               :view-font '("geneva" 12 :srcor :plain)
  143.               :default-button t)
  144.             (make-dialog-item 'alist-dialog-item
  145.               #@(3 25) #@(294 96) "untitled" #'adia
  146.               :view-nick-name 'adi
  147.               :view-font '("monaco" 9 :srcor :plain)
  148.               :cell-size #@(294 12)
  149.               :selection-type :disjoint
  150.               :table-hscrollp nil
  151.               :table-vscrollp t
  152.               :table-sequence nil)))))
  153.  
  154. (make-find-method-dialog)
  155.  
  156. #|
  157. (add-menu-items (find-menu "Edit")
  158.  (make-instance 'menu-item
  159.    :menu-item-title "Find Method..."
  160.    :menu-item-action 'make-find-method-dialog))
  161. |#